home *** CD-ROM | disk | FTP | other *** search
/ BMUG PD-ROM 1995 Fall / PD-ROM F95.toast / Utilities / Text Utils / Alpha 5.81 ƒ / Tcl / UserCode / number.tcl < prev    next >
Encoding:
Text File  |  1994-07-07  |  3.4 KB  |  124 lines  |  [TEXT/ALFA]
  1. # FILE: number.tcl
  2. #
  3. # LAST UPDATE: 01/06/93 4:27:56 AM
  4. #
  5. # This file contains the following TCL procedure(s):
  6. #
  7. #    number -- Returns Roman or alphabetic equivalent numerals
  8. #
  9. #     This proc is useful with electricAlias definitions as follows:
  10. #
  11. #     electricAlias def •Text •i  "§«set item 1; number \$item i»."
  12. #     electricAlias def •Text •ii "§«incr item; number \$item i». "
  13. #     electricAlias def •Text •I  "§«set item 1; number \$item I»."
  14. #     electricAlias def •Text •II "§«incr item; number \$item I». "
  15. #      electricAlias def •Text •a  "§«set item 1; number \$item a»."
  16. #     electricAlias def •Text •aa "§«incr item; number \$item a». "
  17. #      electricAlias def •Text •A  "§«set item 1; number \$item A»."
  18. #     electricAlias def •Text •AA "§«incr item; number \$item A». "
  19. #
  20. # USAGE:
  21. #
  22. #    number VALUE STYLE
  23. #
  24. # WHERE:
  25. #
  26. #    VALUE = positive whole number 1.. (Roman limited to 9999)
  27. #    STYLE = a|alpha|alphabetic|i|roman|A|ALPHA|ALPHABETIC|I|ROMAN
  28. #
  29. # EXAMPLE:
  30. #
  31. #    [number 1992 ROMAN] returns "MCMXCII"
  32. #
  33. #    To use, simply source this file place it in the a folder with the
  34. #    name $HOME:Tcl:Usercode: and invoke it implicitly via the "unknown proc".
  35. #
  36. # SEE ALSO unknown.tcl, electricAlias.tcl
  37.  
  38. # COPYRIGHT:
  39. #
  40. #    Copyright © 1992,1993 by David C. Black
  41. #    All rights reserved.
  42. #
  43. #    Redistribution and use in source and binary forms are permitted
  44. #    provided that the above copyright notice and this paragraph are
  45. #    duplicated in all such forms and that any documentation,
  46. #    advertising materials, and other materials related to such
  47. #    distribution and use acknowledge that the software was developed
  48. #    by David C. Black.
  49. #
  50. #    THIS SOFTWARE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
  51. #    IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
  52. #    WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
  53. #
  54. ################################################################################
  55.  
  56. # AUTHOR
  57. #
  58. #    David C. Black
  59. #    Internet: black@mpd.tandem.com (preferred)
  60. #    GEnie:    D.C.Black
  61. #    USnail:   6217 John Chisum Lane, Austin, TX 78749
  62. #
  63. ################################################################################
  64.  
  65. # HISTORY
  66. #                  
  67. # modified who rev reason
  68. # -------- --- --- ------
  69. # 01/06/93 DCB 1.0 Original
  70.  
  71. proc number {value {style I}} {
  72.     if {$value <= 0} {
  73.         error "Must be a counting number"
  74.     }
  75.     if {[string first "." $value] >= 0} {
  76.         error "Must be an integral value"
  77.     }
  78.     case $style {
  79.         {a alpha alphabetic A ALPHA ALPHABETIC} {
  80.             incr value -1
  81.             set result [format "%c" [expr {$value % 26 + 0x41}]]
  82.             set value [expr {$value / 26}]
  83.             while {$value > 0} {
  84.                 set digit [expr {$value % 26 + 0x40}]
  85.                 set value [expr {$value / 26}]
  86.                 set result [format "%c%s" $digit $result]
  87.             }
  88.         }
  89.         {i roman I ROMAN} {
  90.             if {$value > 9999} {
  91.                 "Roman numeral too big"
  92.             }
  93.             set rlist {
  94.                 {"" I II III IV V VI VII VIII IX}
  95.                 {"" X XX XXX XL L LX LXX LXXX XC}
  96.                 {"" C CC CCC CD D DC DCC DCCC CM}
  97.                 {"" M MM MMM MV_ V_ VM_ VMM_ VMMM_ MX_}
  98.             }
  99.             set result ""
  100.             set ten 0
  101.             while {$value > 0} {
  102.                 set digit [lindex [lindex $rlist $ten] [expr {$value % 10}]]
  103.                 set value [expr {$value / 10}]
  104.                 incr ten
  105.                 set result "$digit$result"
  106.             }
  107.         }
  108.         default {
  109.             error "Unknown numbering style"
  110.         }
  111.     }
  112.     case $style {
  113.         {a alpha alphabetic i roman} {
  114.             return [string tolower $result]
  115.         }
  116.         {A ALPHA ALPHABETIC I ROMAN} {
  117.             return $result
  118.         }
  119.     }
  120. }
  121. #endproc number
  122. ################################################################################
  123.  
  124.